#!/usr/local/bin/perl
##############################################################################
# COPYRIGHT NOTICE                                                           #
# Copyright (c) 1998,1999 Ira L. Gershenhorn.  All Rights Reserved.          #
#                                                                            #
# mgFargo may be used and modified free of charge by anyone so long as       #
# this copyright notice and the comments above remain intact.  By using this #
# code you agree to indemnify Ira L. Gershenhorn from any liability that     #  
# might arise from it's use.                                                 #  
#                                                                            #
# Selling the code for this program without prior written consent is         #
# expressly forbidden.  In other words, please ask first before you try and  #
# make money off of my program.                                              #
#                                                                            #
# Obtain permission before redistributing this software over the Internet or #
# in any other medium.	In all cases copyright and header must remain intact.#
#                                                                            # 
# mgFargo is free software; you can redistribute it and/or modify it		 #
# under the terms of the GNU General Public License as published by the		 #
# Free Software Foundation; either version 2 of the License, or (at			 #
# your option) any later version.											 #
#																			 #
# mgFargo is distributed in the hope that it will be useful, but			 #
# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY #
# or FITNESS FOR A PARTICULAR PURPOSE.&nbsp; See the GNU General Public      #
# License for more details.                                                  #
#																			 #
# You should have received a copy of the GNU General Public License			 #
# along with this program; if not, write to the Free Software				 #
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. #
##############################################################################
# Debug Commands
# perl mgCvt9to8.pl ??

=head1 NAME

B<mgCvt9to8.pl> - Convert a Magic 9.4 export so it looks like a Magic 8.3 export

=head1 SYNOPSIS

C<mgCvt9to8>
Copy your magic 9 export to m9a.exp and it will output to m8a.exp 

For Detailed Help type: mgCvt9to8 -h

=head1 ARGUMENTS

=head1 EXAMPLES


=head1 BUGS

=head2 Planned Enhancements

=head1 SUPPORT

Ira Gershenhorn E<lt>ira@gershenhorn.comE<gt>

=head1 HISTORY
 2006-1203 Created

=head1 AUTHOR

Ira Gershenhorn E<lt>iragershenhorn@mindspring.comE<gt>

=cut

#http://www.rexswain.com/perl5.html#string  a very nice resource
   
   my $infile = "m9a.exp";
   my $cnt = 0;
   my $hasApps = "N";
   my $hasModels = "N";
   my $hasTables = "N";
   my $hasPrgs = "N";
   my $hasHelps = "N";
   my $hasRights = "N";
   my $hasMenus = "N";
   my $hasComp = "N";
   my $hasAppProp = "N";
   my $hasWModels = "N";
   my $hasISN = "N";

   my $rights = 0;
   my $p = 0;#program index
   my $t = 0;#task index
   my $e = 0;#expression index

   print STDOUT "Loading...\n";

   open IN, "< $infile ";
   load();
   close IN;

	# exit here
   sub load{
	   $| = 1;  #flush STDOUT.  otherwise no output for a long time.
	   $_ = <IN>;
	   if (/^VRSN=(\d+)/) { $magicVersion = $1; }
		   else{
			   die "no VSRN?\n";
	   }
	   if ( $magicVersion != "940" ){
		   die "wrong VSRN, expecting 940, got $magicVersion\n";
	   }

	   loadHeader();
	   if ($hasModels=="Y"){loadModels() ;	  }
	   loadFiles();
	   loadMainProg();
	   loadProgs();
	   if ($hasMenus=="Y"){ loadMenus() ;	}
	   loadAppProps();
   }
   sub loadHeader{
	   print STDOUT "Loading Header...\n";
	   do {
		   $_ = <IN>;
		   #print STDOUT $_; print $cnt; print " ";
		   chomp;
		   if (/^APPLICATION=(\d+)/) { $hasApps = $1; }
		   if (/^MODEL=(\d+)/) { $hasModels = $1; }
		   if (/^TABLE=(\d+)/) { $hasTables = $1; }
		   if (/^PROGRAM=(\d+)/) { $hasPrgs = $1; }
		   if (/^HELP=(\d+)/) { $hasHelps = $1; }
		   if (/^RIGHT=(\d+)/) { $hasRights = $1; }
		   if (/^MENU=(\d+)/) { $hasMenus = $1; }
		   if (/^COMPONENT=(\d+)/) { $hasComp = $1; }
		   if (/^APP_PROP=(\d+)/) { $hasAppProp = $1; }
		   if (/^WITH_MODELS=(\d+)/) { $hasWModels = $1; }
		   if (/^ISN=(\d+)/) { $hasISN = $1; }
	   } until ($cnt++ > 100 || /^MODELS=/);
	   if(	$hasApps != "Y" ||
			$hasPrgs != "Y" ||
			$hasTables != "Y"
		 ){
		   die "The export isn't an exported application or it doesn't have Programs or Tables\n";
	   }
   }
	#Load Models until FILE= is encountered
   sub loadModels{
	   print STDOUT "Loading Models...\n";
	   do {
		   #skip the Models.  We don't use them. Just want names.
		   #Just like we ignore Types in Version 8.
		   $_ = <IN>;
	   } until ($cnt++ > 1000 || /^FILE=/);
	   #print $cnt; print " "; print STDOUT $_;
	   print "\n";
   }
   sub loadFiles{
	   print STDOUT "Loading Files...\n";
	   initDataDictionary();
	   do {
		   parseFile();
		   $_ = <IN>;
	   } until ($cnt++ > 5000 || /^PRG_MAIN=/);
	   #print $cnt; print " "; print STDOUT $_;
	   print "\n";
   }
   sub loadMainProg{
	   print STDOUT "Loading Main Program...\n";
	   do {
		   $_ = <IN>;
	   } until ($cnt++ > 9000 || /^PRG=/);
	   #print $cnt; print " "; print STDOUT $_;
	   print "\n";
   }
   sub loadProgs{
	   print STDOUT "Loading Programs...\n";
	   do {
		   parseProg();
		   $_ = <IN>;
	   } until ($cnt++ > 19000 || /^MENU=/);
	   #print $cnt; print " "; print STDOUT $_;
	   print "\n";
   }
   sub loadMenus{
	   print STDOUT "Loading Menus...\n";
	   do {
		   $_ = <IN>;
	   } until ($cnt++ > 99000 || /^CTL=/);
	   #print $cnt; print " "; print STDOUT $_;
	   print "\n";
   }
   sub loadAppProps{
	   print STDOUT "Loading Application Properties...\n";
	   do {
		   $_ = <IN>;
	   } until ($cnt++ > 101000 || eof);
	   print STDOUT "Found EOF, exiting\n";
	   #print $cnt; print " "; print STDOUT $_;
	   print "\n";
   }

   sub loadRights{
	   print STDOUT "Loading Rights...\n";
	   do { #probably not correct
		   if (/^RGHT=\{NAME="(.*?)",KEY="(.*?)",PBLC=(.)/) {
			   $rights++;
			   $rights[$rights]->{name} = $1;
			   $rights[$rights]->{key}  = $2;
			   $rights[$rights]->{public}= $3;
		   }
		   $_ = <IN>;
	   } until ($cnt++ > 101000 || eof);
	   print STDOUT "Found EOF, exiting\n";
	   #print $cnt; print " "; print STDOUT $_;
	   print "\n";
   }

   sub initDataDictionary{
		$ddfile = 0;
		$dd[0]{desc}= 'None';
		$dd[0]{key}->[0]= 'None';
	}
	sub ddFile{
		$desc = $1 if /DESC=\"(.*?)\"/;
		$name = $1 if /NAME=\"(.*?)\"/;#eg DEBUG.DAT for the DBG file
		$ddfile++;
		$ddfield = 0;
		$ddkey = 0;
		$dd[$ddfile]{desc}= $desc;
		$dd[$ddfile]{key}->[0]= 'None';
#		print STDOUT "\n\tFILE: $desc : ";
	}
	sub ddField{
		my $desc = shift;

		$ddfield++;
		$dd[$ddfile]{fields}->[$ddfield]= $desc;
#		print STDOUT " $desc , ";
	}
	sub ddKey {
		$desc = $1 if /DESC=\"(.*?)\"/;
		$ddkey++;
		$dd[$ddfile]{key}->[$ddkey]= $1;
#		print STDOUT " KEY: $desc ";
	}

   sub parseFile{
	   if ( /^FILE=\{(DBNAME|DESC|NAME)/){	ddFile(); }
	   elsif ( /^FIELD=\{DESC=\"(.*?)\",/) {   ddField($1); }
	   elsif ( /^KEY=/){	ddKey();}
	   #don't care about PROPLIST, PROP, SEG elements.
   }

	sub varDesc {
		my $id = shift;
		my $h = $hier;
		my $desc = '?var?';

		while (1) {
			if (defined($var[$p]->{$h}->{$id}->{desc})) {
				$desc = $var[$p]->{$h}->{$id}->{desc};
				last;
			}
			elsif ($h eq '1' ) {
				last;
			}
			else {
				$h =~ s/(\.\d+)$//;   #remove one level
			}
		}
		$desc;
	}
	sub expandedExpression{
		my $in = shift;
		my $lastToken = 'none';
		my $result = '';
		while ($in =~ m{
				 (
				 \'\'           | # null string
				 \'[^\']*?\'    | # strings
				 IF\s\( |
				 \sOR\s |
				 \sAND\s |
				  <> |
				  <= |
				  >= |
				 [&<>\.\-+*,=\(\)\/] | # punctuation
				 [A-Z]+         | # symbols
				 [0-9.]+          #572 attempt to fix problem of spaced out decimal in 0.02 construct
				 )
			   }xg){
			$token = $1;
			if ( $token =~/IF\s\(/){
				$lastToken = 'if';			    $result .= $token . ' ';
			}
			elsif ( $token =~/\s(OR|AND)\s/){
				$lastToken = 'and-or';			    $result .= $token;
			}
			elsif ( $token =~/\'[^\']*?\'/){
				$lastToken = 'string';			$result .= $token;
			}
			elsif ($token =~ /[&<>+*,=\'\(\)\/]/){
				if (($lastToken eq 'string') && ($token eq '&')) {
					$result .= ' ';
				}
				$lastToken = 'punct';
				if( $token eq '=' ){
											$result .= '==' . ' '; #573 use equivalence. There are never assignments within expressions.
				}
				else {
											$result .= $token . ' ';
				}
			}
			else{
				if ($lastToken eq 'string'){
					$lastToken = 'const';		$result .= $token;
				}
				else{
					if ( $token =~ /^[A-Z]{1,2}$/){
						$lastToken = 'var';		$result .= varDesc($token) . ' ';
					}
					else{
						$lastToken = 'keyword';	$result .= $token . ' ';
					}
				}
			}
		}
		$result =~ s/\'([A-Z]+)\'VAR/'@' . varDesc($1)/ge; 	#0586 replace any instances of "'xx'VAR" with "@variable".
		$result;
	}
	sub countBrackets{
		my $count;
		my $rights = 0;
		my $lefts = 0;

		$prevline =~ s/".*?"//g;  #strip out strings so we don't get fooled by brackets inside the strings.
		while ($prevline =~ m/(\}+),/g){
			$rights += length $1;
		}
		while ($prevline =~ m/=(\{)/g){
			$lefts += length $1;
		}
		$count = $rights - $lefts;
	}
	sub	setHierarchicalPosition{
	# EXP: no brackets => subtask, 1 => close current task and next task is on the same level. 2+ => level after ascending n-1 levels.
	# TXT, ACTV, BLOCK: a surfeit of 1 bracket will close the preceding DSP. That's expected.  Any more close previous tasks.
	# OLECLASS: surfeit of 1 bracket: closes prior DIT_INFO, 2: closes prior ITM, 3: closes prior DSP
	# PIC (version 5): surfeit of 1 closes prior ITM, 2: closes prior DSP.
	#
	#0609 HTML Merge
	# What I currently print:
	#	Form: 13 Individual File Heading Class 4 Type:HTMLMerge, Detail, IsChild:N, Color:6, Font:1,Default Table Edit Field~MS Sans Serif~8~0, UOM_FACTOR={X=1,Y=1},
	#	BLOCK={DX=100,DY=10},TMPL_FILE="%template%ruleSmInd.htm",TAG_PRFX="<!$",TAG_SUFX=">",
	#	+-Row-Col-Rows-Cols-Allow------- Name -------------------Attr-Pic---------------------------+
	#
	# Whats in the app export
	#	DSP={
	#	DSP_INFO={NAME="Individual File Heading",CLSS=4,MOD=N,COLOR=6,STYLE=2048,FONT=1,ISCHLD=N,GRIDX=10,GRIDY=10},
	#	UOM_FACTOR={X=1,Y=1},
	#	
	#	FRM={},
	#	BLOCK={DX=100,DY=10},TMPL_FILE="%template%ruleSmInd.htm",TAG_PRFX="<!$",TAG_SUFX=">",
	#	MERGE_PARM={EXP=1,
	#	PIC="300",TXT="GeneratorProgPath"},
	#	MERGE_PARM={EXP=2,
	#	PIC="30",TXT="GenDateTime"},
	#	MERGE_PARM={EXP=3,
	#	PIC="30",TXT="LastModifiedDate"},
	#	MERGE_PARM={FLD="O",
	#	PIC="60",TXT="ProcessDesc"},
	#	MERGE_PARM={FLD="N",
	#	PIC="50",TXT="XPath"},
	#	MERGE_PARM={FLD="P",
	#	PIC="2000",TXT="LongDesc"}},
	#	
		$length = countBrackets();
		$length -= 1 if ($prevline =~ /^(ACTV|TXT|BLOCK)/);
		$length -= 2 if ($prevline =~ /^(PIC)/);
		$length -= 3 if ($prevline =~ /^(OLECLASS)/);
		if ( $length == 0) { #add a level
			$hier .= '.1';
		}
		elsif ($length >= 1 && $hier eq '1') {
			print STDOUT "gotcha\n";
		}
		elsif ($length == 1) {
			$hier =~ s/(\d+)$/$1+1/e;   #move laterally, increment the last number
		}
		else { #move up then over
			$hier = getTaskHier( $length-1 );
			$hier =~ s/(\d+)$/$1+1/e;
		}
	}
	sub initTaskVarsPrescan{#for prescan
		$formNumber=0;
		$vr=0;  #virtual-real index
		$e=1;
		$j=1;
		$v=1;
		$maindbf=0;
	}
   sub parseProg{
	   if (/^EXP="(.*)"[,\}]/){ 
			$exp[$p][$t][$e] = expandedExpression($1);
			$e++;
	   }
	   elsif (/^TSK=/){
			$t++;
			initTaskVarsPrescan();
			setHierarchicalPosition();
#			print STDOUT "hier = $hier\n";
		}
		elsif (/^PRG=/){
			initTaskVarsPrescan();
			$p++;
			$t=1;
			$hier='1';
#			print STDOUT "\n\t $p\n";
		}
		elsif (/^HDR=/ ){  #v055
			$desc = '--';#v055
			$desc = $1 if (/\{DESC="(.+?)",/);#v055
			print STDOUT "\n\t$p.$1" if ($hier eq '1');
			if (!$opt_p || $hier ne '1') {
				$prgtaskName[$p]->{$hier}->{desc} = $1;
				$prgtaskName[$p]->{$hier}->{idx} = $t;
			}
		}
#		else {
#			print STDOUT $_; print "\n";
#		}
   }
